home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / bvecs2.c < prev    next >
C/C++ Source or Header  |  1993-06-29  |  5KB  |  222 lines
  1. /* $Id: bvecs2.c,v 1.1 1992/04/29 12:32:43 pab Exp $
  2.  * 
  3.  * $Log: bvecs2.c,v $
  4.  * Revision 1.1  1992/04/29  12:32:43  pab
  5.  * Initial revision
  6.  *
  7.  * Revision 1.4  1992/01/09  22:28:42  pab
  8.  * Fixed for low tag ints
  9.  *
  10.  * Revision 1.3  1991/12/22  15:13:49  pab
  11.  * Xmas revision
  12.  *
  13.  * Revision 1.2  1991/09/11  12:07:00  pab
  14.  * 11/9/91 First Alpha release of modified system
  15.  *
  16.  * Revision 1.1  1991/08/12  16:49:26  pab
  17.  * Initial revision
  18.  *
  19.  * Revision 1.4  1991/02/11  21:24:13  pab
  20.  * tidied up...
  21.  *
  22.  * Revision 1.3  1991/02/04  17:33:39  kjp
  23.  * classof() standardisation.
  24.  *
  25.  * Revision 1.2  1990/11/29  22:45:19  pab
  26.  * Got vector arithmetic right. added integer->bit-vector
  27.  * NB: vectors indexed from 0. always have been. Always will be.
  28.  *
  29.  *   (CB) rewritten 4/24/92
  30.  *    Modified by pab
  31.  */
  32. /* ******************************************************************** */
  33. /* bit-vectors.c     Copyright (C) Codemist and University of Bath 1990 */
  34. /*                                                                      */
  35. /* Just so                                                    */
  36. /* ******************************************************************** */
  37.  
  38. /*
  39.  * Change Log:
  40.  *   Version 1, September 1990
  41.  *    28/11/90 added bit-vector->integer
  42.  *  
  43.  */
  44.  
  45. #include <stdio.h>
  46. #include "funcalls.h"
  47. #include "defs.h"
  48. #include "structs.h"
  49. #include "global.h"
  50. #include "error.h"
  51. #include "allocate.h"
  52. #include "class.h"
  53. #include "modboot.h"
  54. #include "bootstrap.h"
  55.  
  56. static LispObject Bit_Vector;
  57.  
  58. #define BV_BUG(x) 
  59.  
  60. static EUFUN_1(Fn_make_bit_vector, lisplen)
  61. {
  62.   LispObject new;
  63.   int bytes,len;
  64.  
  65.   if (!is_fixnum(lisplen))
  66.     CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
  67.  
  68.   len = intval(lisplen);
  69.   
  70.   if (len <= 0)
  71.     CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
  72.  
  73.   bytes = sizeof(int)+len/8 + 1;
  74. #if 0
  75.   str = (char *)feel_malloc(bytes + 1);
  76.   str[bytes - 1] = '\0';
  77.   str[0] = len;
  78.   for (len = 1 ; len < bytes ; len++)
  79.     str[len] = 0;
  80. #endif
  81.   new = allocate_string(stacktop, "", bytes);  
  82.   *(int *)stringof(new)=len;
  83.   BV_BUG(fprintf(stderr,"alloc: %x %d\n", new,bytes));
  84.  return(new);
  85. }
  86. EUFUN_CLOSE
  87.  
  88. EUFUN_1( Fn_bit_vector_length, v)
  89. {
  90.   if (!is_string(v))
  91.     CallError(stacktop,"bit-vector-length: bad bit vector",v,NONCONTINUABLE);
  92.  
  93.   return(allocate_integer(stacktop, *((int *) stringof(v))));
  94. }
  95. EUFUN_CLOSE
  96.   
  97. EUFUN_2( Fn_bit_vector_ref,  v, i)
  98. {
  99.   int index,byte,bit;
  100.   int size;
  101.   char *str;
  102.  
  103.   if (!is_string(v))
  104.     CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
  105.  
  106.   str = stringof(v);
  107.   size = *((int *) &str[0]);
  108.  
  109.   if (!is_fixnum(i))
  110.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  111.  
  112.   index = intval(i);
  113.   if (index < 0 || index >= size)
  114.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  115.  
  116.   byte = index/8;
  117.   bit = index%8;
  118.   str+=sizeof(int);
  119.  
  120.   if ((1 << bit) & str[byte])
  121.     return(allocate_integer(stacktop,1));
  122.   else
  123.     return(allocate_integer(stacktop,0));
  124. }
  125. EUFUN_CLOSE
  126.  
  127. EUFUN_3( Fn_bit_vector_ref_setter, v, i, val)
  128. {
  129.   int index,byte,bit;
  130.   int size,state;
  131.   char *str;
  132.   
  133.   if (!is_string(v))
  134.     CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
  135.  
  136.   str = stringof(v);
  137.   
  138.   size = *((int *) &str[0]);
  139.  
  140.   if (!is_fixnum(i))
  141.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  142.  
  143.   index = intval(i);
  144.   if (index < 0 || index >= size)
  145.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  146.  
  147.   if (!is_fixnum(val))
  148.     CallError(stacktop,
  149.           "(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
  150.  
  151.   if ((state = intval(val)) != 0 && state != 1)
  152.     CallError(stacktop,
  153.           "(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
  154.  
  155.   byte = index/8;
  156.   bit = index%8;
  157.  
  158.   if (state == 1)
  159.     str[byte+sizeof(int)] |= (char) (1 << bit);
  160.   else
  161.     str[byte + sizeof(int)]  &= (char) ~(1 << bit);    
  162.  
  163.   return(v);
  164. }
  165. EUFUN_CLOSE
  166.  
  167. static EUFUN_1(Fn_convert_int,num)
  168. {    
  169.   LispObject new;
  170.   unsigned char *ptr,*dest_ptr;
  171.   int tmp,i;
  172.   
  173.   tmp=intval(num);
  174.   ptr=(unsigned char *)&tmp;
  175.   
  176.   new=allocate_string(stacktop,"",sizeof(int));
  177.   dest_ptr=(unsigned char *)stringof(new);
  178.   /* Hmm, let's assume that this is big-endian */
  179. #if 1  
  180.   for (i=0; i < sizeof(int) ; i++)
  181.     {
  182.       dest_ptr[i] = ptr[sizeof(int) - (i+1)];
  183.     }
  184. #else
  185.   for (i=0; i < sizeof(int) ; i++)
  186.     v_ptr[i] = v_buf[i];
  187. #endif
  188.  
  189. }
  190. EUFUN_CLOSE
  191.  
  192.  
  193. #define BIT_VECTORS_ENTRIES (5)
  194. MODULE Module_bit_vectors;
  195. LispObject Module_bit_vectors_values[BIT_VECTORS_ENTRIES];
  196.  
  197. void initialise_bit_vectors(LispObject *stacktop)
  198. {
  199.   extern void set_anon_associate(LispObject *,LispObject,LispObject);
  200.   LispObject get,set;
  201.  
  202.   open_module(stacktop,&Module_bit_vectors,Module_bit_vectors_values,
  203.           "bit-vectors",BIT_VECTORS_ENTRIES);
  204.  
  205.   (void) make_module_function(stacktop,"primitive-make-bit-vector",
  206.                   Fn_make_bit_vector,1);
  207.   (void) make_module_function(stacktop,"integer-to-bitvector",
  208.                   Fn_make_bit_vector,1);
  209.   (void) make_module_function(stacktop,
  210.                   "bit-vector-length",Fn_bit_vector_length,1);
  211.   get = make_module_function(stacktop,"primitive-bit-vector-ref",Fn_bit_vector_ref,2);
  212.   STACK_TMP(get);
  213.   set = make_unexported_module_function(stacktop,"primitive-bit-vector-ref-setter",
  214.                     Fn_bit_vector_ref_setter,3);
  215.   UNSTACK_TMP(get);
  216.   set_anon_associate(stacktop,get,set);
  217.  
  218.   close_module();
  219. }
  220.  
  221.              
  222.